perm filename KSORT.PAS[S1,ALS] blob sn#392601 filedate 1978-11-02 generic text, type T, neo UTF8
(*$L+*)
PROGRAM KSORT(INPUT*,OUTPUT,FILEK*,FILE1,FILE2,FILE3 );

(**********************************************************************)
CONST
MAXSORT=	256;
MAXINDX=	257;
MAXITEM=	160;
MAXKEY=		80;
MAXWORD=	16;
MAXWRDX=	17;
MAXSTACK=	200;
M=		9;

TYPE
SORTINDX=	0 .. MAXINDX;
BYTEINDX=	0 .. 5;
CHARINDX=	0..MAXITEM;
ITEMINDX=	0..MAXITEM;
KEYINDX=	0..MAXKEY;
WORDINDX=	0..MAXWRDX;
TMPINDX=	0 .. 21;
SORTARY=	ARRAY [SORTINDX,WORDINDX]  OF INTEGER;
CHARARY=	ARRAY [SORTINDX,CHARINDX] OF CHAR;
TMPARY=		ARRAY [TMPINDX] OF INTEGER;
KEYARY=		ARRAY [KEYINDX] OF INTEGER;
FILEK=		FILE OF CHAR;
FILE1=		FILE OF INTEGER;
FILE2=		FILE OF INTEGER;
FILE3=		FILE OF INTEGER;

VAR

A:	SORTARY;
B:	CHARARY;
KEY:		KEYARY;
BK:		INTEGER;
(**********************************************************************)
(*
PROCEDURE GETKEY(VAR KEY: KEYARY);
LABEL 1,2;

VAR
J:	KEYINDX;
K:	INTEGER;
C:	CHAR;

BEGIN
FOR J:=1 TO 80 DO KEY[J]:=0;
RESET(FILEK);
J:=1; K:=0;  
WHILE NOT EOF DO BEGIN
1:
  READ(FILEK,C); IF C>='0' THEN IF C<='9' THEN BEGIN
    K:=K*10+ORD(C); GOTO 1; END;
  IF K<>0 THEN BEGIN
    KEY[J]:=K; K:=0; J:=J+1; END;
  IF J>80 THEN GOTO 2;
END;
2:
END;
*)
(**********************************************************************)
PROCEDURE LOADA(VAR A: SORTARY; B: CHARARY; KEY: KEYARY; BK: INTEGER);
LABEL 1,2,3,4;
VAR
I:	INTEGER;
J:	INTEGER;
K:	INTEGER;
L:	INTEGER;
P:	INTEGER;
N:	INTEGER;
C:	CHAR;
CK:	CHAR;

BEGIN
I:=1; J:=1;  K:=1; L:=1;
RESET(INPUT);
WHILE NOT EOF DO BEGIN
  L:=1;
  WHILE NOT EOLN DO BEGIN
    READ(INPUT,C);
    B[I,L]:=C; L:=L+1; IF L>MAXITEM THEN GOTO 2; END;
  FOR L:=L TO MAXITEM DO B[I,L]:=' ';
2:
  N:=1; K:=1;
  FOR P:=1 TO MAXKEY DO BEGIN
    L:=KEY[P]; IF L=0 THEN GOTO 3 ELSE BEGIN
      A[I,K]:=A[I,K]*128+ ORD(B[I,L]); 
      N:=N+1; IF N>5 THEN BEGIN K:=K+1; N:=1; END;
    END;
3:
  FOR N:=N TO 5 DO A[I,K]:=A[I,K]*128;
  FOR K:=K+1 TO MAXWORD DO A[I,K]:=0;
  K:=MAXWRDX; A[I,K]:=BK+I;
  I:=I+1; K:=1;
  READLN(INPUT);
  IF I> MAXSORT THEN GOTO 4;
  END;
4:
  BK:=BK+1;
END;
(**********************************************************************)
PROCEDURE WRTINT(I,LEN: INTEGER);

VAR
POW10:	INTEGER;
NEG:	BOOLEAN;
DIGS:	INTEGER;
TMP:	INTEGER;

BEGIN

  NEG:=FALSE;
  IF I<0 THEN BEGIN
    LEN:=LEN-1;
    NEG:=TRUE;
    I:=-I;
  END;

  DIGS:=0;
  TMP:=I;
  POW10:=1;
  REPEAT
    TMP:=TMP DIV 10;
    POW10:=POW10*10;
    DIGS:=DIGS+1;
  UNTIL TMP=0;

  FOR TMP:=LEN DOWNTO DIGS DO BEGIN
    WRITE(' ');
  END;

  IF NEG THEN BEGIN
    WRITE('-');
  END;
  
  REPEAT
    POW10:=POW10 DIV 10;
    TMP:=I DIV POW10;
    WRITE(CHR(TMP+ORD('0')));
    I:=I MOD POW10;
  UNTIL POW10=1;

END;
(**********************************************************************)
PROCEDURE TREE(VAR A: SORTARY);

LABEL	1,2,10,11,12,13;

TYPE
KINDX=	0..MAXWRDX;

VAR
I,
J,
L:	SORTINDX;
K:	WORDINDX;
T:	ARRAY [1..MAXWRDX] OF INTEGER;

BEGIN

FOR I:=2 TO MAXINDX DO BEGIN
  L:=I;
  J:=I;
  FOR K:=1 TO MAXWRDX DO T[K]:=A[I,K];
11:
  REPEAT
    J:=J DIV 2;
    K:=1;
    IF T[K]<A[J,K] THEN GOTO 1;
    WHILE (T[K]=A[J,K] AND K<MAXWRDX) DO K:=K+1;
    IF T[K]<=A[J,K] THEN GOTO 1;
    FOR K:=1 TO MAXWRDX DO A[L,K]:=A[J,K];
    L:=J;
  UNTIL J=1;

  1:
10: 
  FOR K:=1 TO MAXWRDX DO  A[L,K]:=T[K];
  K:=1;
END;

FOR I:=MAXINDX-1 DOWNTO 1 DO BEGIN
  FOR K:=1 TO MAXWRDX DO BEGIN
   T[K]:=A[I+1,K];
   A[I+1,K]:=A[1,K]; END;
  K:=1;
  L:=1;
  J:=2;
  WHILE J<=I DO BEGIN
    IF J<I THEN BEGIN
      K:=1;
      WHILE (A[J+1,K]=A[J,K] AND K<MAXWRDX) DO K:=K+1;
      IF A[J+1,K]>A[J,K] THEN J:=J+1;
      END;
    K:=1;
    WHILE (A[J,K]=T[K] AND K<MAXWRDX) DO K:=K+1;
    IF A[J,K]>T[K] THEN BEGIN
      FOR K:=1 TO MAXWRDX DO A[L,K]:=A[J,K];
      L:=J;
      J:=2*J;
      END ELSE GOTO 2;
  END;
  2:
  FOR K:=1 TO MAXWRDX DO  A[L,K]:=T[K];
  K:=1;
END;

END;

(**********************************************************************)
PROCEDURE QUICK(VAR A: SORTARY);
LABEL	1,2,3,4,5,6,10,11;
CONST
INFINITY=	2147483647;
TYPE
KINDX=	0..16;
VAR
P,
L,
R,
I,
J,
K:	KINDX;
T:	INTEGER;
TMP,
V:	ARRAY [1..WORDMAX] OF INTEGER;
STACK:	ARRAY [0 .. MAXSTACK] OF INTEGER;

BEGIN
FOR K:=1 TO 16 DO BEGIN
A[0,K]:=-INFINITY;
A[MAXSORT+1,K]:=INFINITY; END;

P:=0; L:=1; R:=MAXSORT;

1:
I:=L; J:=R+1;
FOR K:=1 TO 16 DO  V[K]:=A[L,K];
WHILE I<J DO BEGIN
  I:=I+1; K:=1;
10:
  WHILE A[I,K]<V[K] DO I:=I+1;
  WHILE (A[I,K]=V[K] AND K<16) DO K:=K+1; 
  IF A[I,K]<V[K] THEN BEGIN I:=I+1; K:=1; GOTO 10; END;
  J:=J-1; K:=1;
11:
  WHILE A[J,K]>V[K] DO J:=J-1;
  WHILE (A[J,K]=V[K] AND K<16)DO K:=K+1;
  IF A[J,K]>V[K] THEN BEGIN J:=J-1; K:=1; GOTO 11; END;
  K:=1;
  FOR K:=1 TO 16 DO BEGIN
  TMP[K]:=A[J,K];
  A[J,K]:=A[I,K];
  A[I,K]:=TMP[K];
  END;
END;
FOR K:=1 TO 16 DO BEGIN
TMP[K]:=A[J,K];
A[J,K]:=A[L,K];
A[L,K]:=A[I,K];
A[I,K]:=TMP[K];
END;
IF (R-J)>(J-L) THEN GOTO 3;
IF (J-L)<=M THEN GOTO 5;
IF (R-J)<=M THEN GOTO 4;
P:=P+2;
STACK[P]:=L;
STACK[P+1]:=J-1;

2:
L:=J+1;
GOTO 1;

3:
IF (R-J)<=M THEN GOTO 5;
IF (J-L)<=M THEN GOTO 2;
P:=P+2;
STACK[P]:=J+1;
STACK[P+1]:=R;

4:
R:=J-1;
GOTO 1;

5:
L:=STACK[P];
R:=STACK[P+1];
P:=P-2;
IF P>=0 THEN GOTO 1;

6:
FOR I:=2 TO MAXSORT DO BEGIN
  FOR K:=1 TO 16 DO  V[K]:=A[I,K];
  J:=I-1;
12:
  K:=1;
  WHILE A[J,K]>V[K] DO BEGIN
    FOR K:=1 TO 16 DO A[J+1,K]:=A[J,K];
    J:=J-1;
  END;
  WHILE (A[J+1,K]=V[K] AND K<16) DO  K:=K+1;
  IF A[J+1,K]>V[K] THEN BEGIN
    FOR K:=1 TO 16 DO A[J+1,K]:=A[J,K]; J:=J-1; GOTO 12; END;
  FOR K:=1 TO 16 DO  A[J+1,K]:=V[K];
  K:=1;
END;

END;

(**********************************************************************)

BEGIN


END.
(**********************************************************************)